home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PASCALL / CLOCKIN / CLOCK1.PAS < prev    next >
Pascal/Delphi Source File  |  1992-12-25  |  5KB  |  171 lines
  1. program graphclock;
  2. uses
  3.      graph,graphin1,dos,crt;
  4. label
  5.      1;
  6. var
  7.      beeper,stop:boolean;
  8. const
  9.      lasthour:word=hrhandsize;
  10.      lastminute:word=minhandsize;
  11.      lastsecond:word=sechandsize;
  12.      lasthundrethofasecond:word=hndthsechandsize;
  13. var
  14.      hour,minute,second,hundrethofasecond:word;
  15.      txh,txw,txs,tys:integer;
  16.  
  17.  
  18. function printmonth(month:word):string;
  19. begin
  20.      case month of
  21.           1: printmonth:='january';
  22.           2: printmonth:='february';
  23.           3: printmonth:='march';
  24.           4: printmonth:='april';
  25.           5: printmonth:='may';
  26.           6: printmonth:='june';
  27.           7: printmonth:='july';
  28.           8: printmonth:='august';
  29.           9: printmonth:='september';
  30.           10: printmonth:='october';
  31.           11: printmonth:='november';
  32.           12: printmonth:='december'
  33.           else exit;
  34.      end;
  35. end;
  36.  
  37.  
  38. function printdayofweek(day:word):string;
  39. begin
  40.      case day of
  41.           0: printdayofweek:='sunday';
  42.           1: printdayofweek:='monday';
  43.           2: printdayofweek:='tuesday';
  44.           3: printdayofweek:='wednesday';
  45.           4: printdayofweek:='thursday';
  46.           5: printdayofweek:='friday';
  47.           6: printdayofweek:='saturday'
  48.           else exit;
  49.      end;
  50. end;
  51.  
  52. procedure preset;
  53. begin
  54.      txh:=textheight('d');
  55.      txw:=textwidth('d');
  56.      setcolor(white);
  57.      txs:=textwidth('  :  :  .   ');
  58.      txs:=centerx-(txs-txw div 2) div 2;
  59.      tys:=centery-txh div 2;
  60.      outtextxy(txs+1,tys+1,'  :  :  .   ');
  61. end;
  62.  
  63. procedure putoutclocktimer;
  64. {var
  65.      txx:integer;}
  66. begin
  67.           gettime(hour,minute,second,hundrethofasecond);
  68.           setcolor(white);
  69. {          txx:=centerx-(txs-txw div 2) div 2;
  70.           bar(txx,tys,txx+11*txs,tys+txh);
  71.           outtextxy(txx+1,tys+1,concat(streng(hour),':',streng(minute),':',streng(second),'.',streng(hundrethofasecond)));}
  72.           if not(lasthour=hour) then begin
  73.                puthand(lasthour,hour,hr);
  74.                lasthour:=hour;
  75.                setcolor(white);
  76.                bar(txs,tys,txs+2*txw,tys+txh);
  77.                if hour=0 then hour:=hrhandnumber;
  78.                outtextxy(txs+1,tys+1,streng(hour));
  79.           end;
  80.           if not(lastminute=minute) then begin
  81.                puthand(lastminute,minute,min);
  82.                lastminute:=minute;
  83.                setcolor(white);
  84.                bar(txs+3*txw,tys,txs+5*txw,tys+txh);
  85.                if minute=0 then minute:=minhandnumber;
  86.                outtextxy(txs+3*txw,tys+1,streng(minute));
  87.           end;
  88.           if not(lastsecond=second) then begin
  89.                puthand(lastsecond,second,sec);
  90.                setcolor(white);
  91.                bar(txs+6*txw,tys,txs+8*txw,tys+txh);
  92.                if (beeper) and not(lastsecond=second) then beep;
  93.                lastsecond:=second;{
  94.                if second=0 then second:=sechandnumber;
  95.                outtextxy(txs+6*txw,tys+1,streng(second));
  96.           end;
  97.           if not(lasthundrethofasecond=hundrethofasecond) then begin
  98.                puthand(lasthundrethofasecond,hundrethofasecond,hndthsec);
  99.                lasthundrethofasecond:=hundrethofasecond;
  100.                setcolor(white);
  101.                bar(txs+9*txw,tys,txs+12*txw,tys+txh);
  102.                if hundrethofasecond=0 then hundrethofasecond:=hndthsechandnumber;
  103.                outtextxy(txs+9*txw,tys+1,streng(hundrethofasecond));
  104.           end;
  105. end;
  106.  
  107. function inkey:char;
  108. begin
  109.      if keypressed then inkey:=readkey else inkey:=chr(1);
  110. end;
  111.  
  112. {procedure putoutclock;
  113. const
  114.      lasthour:word=hrhandsize;
  115.      lastminute:word=minhandsize;
  116.      lastsecond:word=sechandsize;
  117.      lasthundrethofasecond:word=hndthsechandsize;
  118. var
  119.      hour,minute,second,hundrethofasecond:word;
  120. begin
  121.      repeat
  122.           gettime(hour,minute,second,hundrethofasecond);
  123.           if not(lasthour=hour) then begin
  124.                puthand(lasthour,hour,hr);
  125.                lasthour:=hour;
  126.           end;
  127.           if not(lastminute=minute) then begin
  128.                puthand(lastminute,minute,min);
  129.                lastminute:=minute;
  130.           end;
  131.           if not(lastsecond=second) then begin
  132.                puthand(lastsecond,second,sec);
  133.                if beeper then beep;
  134.                lastsecond:=second;
  135.           end;
  136.           if not(lasthundrethofasecond=hundrethofasecond) then begin
  137.                puthand(lasthundrethofasecond,hundrethofasecond,hndthsec);
  138.                lasthundrethofasecond:=hundrethofasecond;
  139.           end;
  140.      until keypressed;
  141. end;}
  142.  
  143. procedure done;
  144. begin
  145.      restorecrtmode;
  146.      closegraph;
  147.      halt;
  148. end;
  149.  
  150. procedure doit;
  151. begin
  152.           putoutclocktimer;
  153.           case ord(upcase(inkey)) of
  154.                27:done;
  155.                ord('S'):beeper:=not(beeper);
  156.           end;
  157.           centerc:=centerx;
  158. end;
  159.  
  160. begin
  161.      beeper:=true;
  162.      setupgraph;
  163.      setupgrid;
  164.      preset;
  165.      centerx:=319
  166. 1:
  167. {     for centerx:=241 to 399 do doit;
  168.      for centerx:=399 downto 241 do doit;}
  169.      doit;
  170.      goto 1;
  171. end.